(define-imported-class (unknown-member-exception (object obj) (string offender)) meta-exception)

(import-static (my-get-members "Utilities.GetMembers"
			       (proc (clr-type string)
				     (type-expression-value '(array member-info)))))

(%import-object 'root-namespace-kluge
		"Namespace.RootNamespace"
		(type-expression-value 'namespace))

(let ((member-info (type-expression-value 'member-info)))
  (import-methods (get-base-definition "GetBaseDefinition"
				       (proc (member-info) member-info))))

(define-imported-class (linked-list (object head) (ilist tail)) ilist)
(define-imported-class member-reference expression)
(define-imported-class user-procedure procedure
  (define (set-documentation (string s)) (public) void))

(define-imported-class (member-accessor (string name)) object
  (define (read-accessor "Read" (object o)) (public) object)
  (define (write-accessor "Write" (object o) (object new-value)) (public) void)
  (define (method-call-invoke "Invoke"
			      (object ob)
			      ((array object) args)
			      (eval-stack e))
    (public) object))

(define-initialized-module (lisp special-forms)
  (define-class (definition dvar dval doc) expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define dvar "variable" (public global-variable) null)
    (define dval "value" (public expression) null)
    (define doc "documentation" (public string) null)

    (define (simplify d parent tail?)
      (let ((var (dvar d))
	    (saved-current-source-definition current-source-definition))
	(let ((nam (pname (vname var))))
	  (set current-source-definition nam)
	  (set (enclosing-expression d) parent)
	  (set (dval d)
	       (simplify (dval d)
			 d
			 #f))
	  ;; Manually shallow-bind it because it's too much of a
	  ;; pain to make the delegate we need to call Fluid.Bind.
	  (set current-source-definition
	       saved-current-source-definition)
	  d)))

    (define (unparse d)
      (new-array object 3
		 s-define
		 (vname (dvar d))
		 (unparse (dval d))))

    (define (subexpressions e)
      (new-array object 1 (dval e)))

    (define (eval d env estack)
      (now-evaluating estack d env
		      (let ((v (eval (dval d) env estack))
			    (dv (dvar d)))
			(define-global dv v (doc d))
			v))))

  (define-parser (quote "value")
    "Makes the following value a constant.\\nWords are interpreted as symbols, not variables.\\nBracketed expressions are interpreted as lists, not procedure calls."
    quote-parser null tuple p
    (check-length tuple 2 2)
    (new constant (vector-ref tuple 1)))

  (define-parser (define "variable" "value")
    "Creates/redefines a name with a specified value.\\n[define name value], or\\n[define [name args...] result]"
    definition-parser s-body tuple p
    (when (= (count tuple) 1)
      (throw (malformed-definition-error "No variable name or value specified in definition"
					 tuple)))
    (when (= (count tuple) 2)
      (if (is? (vector-ref tuple 1)
	       ilist)
	  (throw (malformed-definition-error "No return value is specified for the procedure"
					     tuple))
	  (throw (malformed-definition-error "No value specified for the variable"
					     tuple))))
    (unless (or (= (count tuple) 3)
		(and (> (count tuple)
			2)
		     (is? (vector-ref tuple 1) ilist))
		(and (= (count tuple) 4)
		     (is? (vector-ref tuple 2) string)))
      (throw (malformed-definition-error "Not a valid definition"
					 tuple)))
    (let ((sig (vector-ref tuple 1)))
      (let ((var-sym (as sig symbol))
	    (l (as sig ilist)))
	(cond ((not (null? l))
	       (let ((args (rest l))
		     (body (rest (rest tuple))))
		 (let ((fn (new-array object (+ (count args)
						(count body)
						1))))
		   (copy-into args fn 0)
		   (copy-into body fn (+ (count args) 1))
		   (declare-source-alias fn tuple)
		   (set (vector-ref fn (count args)) lambda-arrow)
		   (parse this
			  (new-array object 3
				     s-define
				     (vector-ref l 0)
				     fn)
			  p))))
	      ((null? var-sym)
	       (throw (malformed-definition-variable-error
		       "Defining something that isn't a variable?"
		       tuple
		       sig)))
	      (else
	       (let ((var (lookup default-namespace-kluge var-sym #f #t #t))
		     (saved-current-source-definition current-source-definition))
		 (let ((nam (pname (vname var))))
		   (set current-source-definition nam)
		   (set (source-file var) current-source-file)
		   (set (defined-in var) nam))
		 (let ((result (if (= (count tuple) 3)
				   (new definition
					var
					(parse p (vector-ref tuple 2) p)
					null)
				   (new definition
					var
					(parse p (vector-ref tuple 3) p)
					(cast string (vector-ref tuple 2))))))
		   ;; Manually shallow-bind it because it's too much of a
		   ;; pain to make the delegate we need to call Fluid.Bind.
		   (set current-source-definition
			saved-current-source-definition)
		   result)))))))

  (define-class (variable-assignment var new-value) expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define var (public variable) null)
    (define new-value (public expression) null)

    (define (simplify v parent tail?)
      (set (enclosing-expression v) parent)
      (set (new-value v)
	   (simplify (new-value v)
		     v
		     #f))
      v)

    (define (unparse e)
      (new-array object 3
		 (unparse (var e))
		 assignment-arrow
		 (unparse (new-value e))))

    (define (subexpressions e)
      (new-array object 1 (new-value e)))

    (define (eval e env estack)
      (now-evaluating! estack e env
		      (eval-preamble e env)
		      (set-value! (var e) (eval (new-value e)
						env
						estack)
				  env))
      missing-value))

  (define-class (conditional test consequent alternative) expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define test (public expression) null)
    (define consequent (public expression) null)
    (define alternative (public expression) null)

    (define (simplify c parent tail?)
      (set (enclosing-expression c) parent)
      (set (test c)
	   (simplify (test c) c #f))
      (set (consequent c)
	   (simplify (consequent c) c tail?))
      (unless (null? (alternative c))
	(set (alternative c)
	     (simplify (alternative c) c tail?)))
      c)

    (define (unparse c)
      (let ((t (test c))
	    (con (consequent c))
	    (alt (alternative c)))
	(if (null? alt)
	    (new-array object 3
		       s-if
		       (unparse t)
		       (unparse con))
	    (new-array object 4
		       s-if
		       (unparse t)
		       (unparse con)
		       (unparse alt)))))

    (define (subexpressions c)
      (if (null? (alternative c))
	  (new-array object
		     2
		     (test c)
		     (consequent c))
	  (new-array object
		     3
		     (test c)
		     (consequent c)
		     (alternative c))))

    (define (eval c env estack)
      (now-evaluating estack c env
		      (eval-preamble c env)
		      (let ((t (eval (test c) env estack)))
			(set-expression! estack c env)
			(unless (is? t boolean)
			  (throw (test-type-exception "The value of the test in an if expression was not a boolean"
						  t)))
			(cond ((cast boolean t)
			       (eval (consequent c) env estack))
			      ((eq? (alternative c) null)
			       missing-value)
			      (else
			       (eval (alternative c) env estack)))))))

  (define-parser (if "test" "consequent" "[alternative]")
    "Runs test, returns consequent, if true, otherwise alternative.\\n[if test consequent alternative] or\\n[if test consequent] if not alternative desired.\\nUse cond for many tests and/or many expressions to run.\\nUse when or unless for a single test but many expressions to run."
    conditional-parser null tuple p
    (unless (or (= (count tuple) 3)
		(= (count tuple) 4))
      (throw (new parse-error
		  "If should be followed by a test, and at most two other expressions"
		  tuple)))
    (if (= (count tuple) 3)
	(new conditional
	     (parse p (vector-ref tuple 1) p)
	     (parse p (vector-ref tuple 2) p)
	     null)
	(new conditional
	     (parse p (vector-ref tuple 1) p)
	     (parse p (vector-ref tuple 2) p)
	     (parse p (vector-ref tuple 3) p))))

  (define-class shortcircuit-logic-expression expression
    ("[Serializable]")
    (define conditions (public (array expression)) null)

    (define (subexpressions s)
      (conditions s))

    (define (simplify s parent tail?)
      (set (enclosing-expression s) parent)
      (dotimes (i (length (conditions s)))
	(set (vector-ref (conditions s) i)
	     (simplify (vector-ref (conditions s) i)
		       s
		       #f)))
      s))
    
  (define-class (conjunction conditions) shortcircuit-logic-expression
    ("[Serializable]")
    (define (unparse c)
      (let ((u (new-array object (+ (length (conditions c)) 1))))
	(set (vector-ref u 0)
	     s-and)
	(dotimes (n (length (conditions c)))
	  (set (vector-ref u (+ n 1))
	       (unparse (vector-ref conditions n))))
	u))

    (define (eval c e estack)
      (now-evaluating estack c e
		      (really-eval c e estack)))

    (define (really-eval c (environment e) (eval-stack estack))
      (private object)
      (let ((t (conditions c)))
	(dotimes (n (length t))
	  (let ((test (checked-test-cast "The value of a test in an AND expression was not a Boolean"
					 (eval (vector-ref t n)
					       e
					       estack))))
	  (unless test
	    (return false))))
	(return true))))

  (define-parser (and "conditions ..")
    "True when all the enclosed conditions are true.\\nExecution proceeds left to right.\\nExecution stops with the first false condition."
    and-parser null tuple p
    (when (< (count tuple) 2)
      (throw (parse-error "And expression has no subexpressions"
			  tuple)))
    (let ((c (new-array expression (- (count tuple) 1))))
      (dotimes (n (length c))
	(set (vector-ref c n)
	     (parse p (vector-ref tuple (+ n 1)) p)))
      (conjunction c)))

  (define-class (disjunction conditions) shortcircuit-logic-expression
    ("[Serializable]")
    (define (unparse c)
      (let ((u (new-array object (+ (length (conditions c)) 1))))
	(set (vector-ref u 0)
	     s-or)
	(dotimes (n (length (conditions c)))
	  (set (vector-ref u (+ n 1))
	       (unparse (vector-ref conditions n))))
	u))

    (define (eval c e estack)
      (now-evaluating estack c e
		      (really-eval c e estack)))

    (define (really-eval c (environment e) (eval-stack estack)) (private object)
      (let ((t (conditions c)))
	(dotimes (n (length t))
	  (let ((test (checked-test-cast "The value of a test in an AND expression was not a Boolean"
					 (eval (vector-ref t n)
					       e
					       estack))))
	  (when test
	    (return true))))
	(return false))))

  (define-parser (or "conditions ..")
    "True when any of the enclosed conditions are true.\\nExecution proceeds left to right.\\nExecution stops with the first true condition."
    or-parser null tuple p
    (when (< (count tuple) 2)
      (throw (parse-error "Or expression has no subexpressions"
			  tuple)))
    (let ((c (new-array expression (- (count tuple) 1))))
      (dotimes (n (length c))
	(set (vector-ref c n)
	     (parse p (vector-ref tuple (+ n 1)) p)))
      (disjunction c)))

  (define-class (begin-expression body) body-expression
    ("[Serializable]")
    (define (initialize! this) (public base void)
      (base-initializer this))

    (define (simplify b parent tail?)
      (cond ((= (length (body b))
		1)
	     (simplify (vector-ref (body b) 0)
		       parent
		       tail?))
	    (else
	     (set (enclosing-expression b) parent)
	     (dotimes (i (length (body b)))
	       (set (vector-ref (body b) i)
		    (simplify (vector-ref (body b) i)
			      b
			      (if (= i
				     (- (length (body b))
					  1))
				  tail?
				  #f))))
	     b)))

    (define (unparse be)
      (let ((b (body be)))
	(let ((up (new-array object (+ (length b) 1))))
	  (set (vector-ref up 0)
	       s-begin)
	  (dotimes (i (length b))
	    (set (vector-ref up (+ i 1))
		 (unparse (vector-ref b i))))
	  up)))

    (define (subexpressions be)
      (body be))

    (define (eval b env estack)
      (now-evaluating estack b env
		      (eval-preamble b env)
		      (eval-body (body b) env estack))))

  (define-parser (begin "body ...")
    "Executes all the enclosed expressions in order.\\nReturns the value of the last expression."
    begin-parser null arr p
    (when (< (count arr) 2)
      (throw (missing-body-error "Begin expression has no result expression(s)"
					   arr)))
    (parse-body arr 1 p #f))

  ;;;
  ;;; FIELD REFERENCES
  ;;;
  (define-class (member-reference exp member-name) expression
    ("[Serializable]")
    (define exp "expression" (public expression) null)
    (define member-name (public string) null)
    (define accessor "memberAccessor" (public "[NonSerialized]" member-accessor) null)

    (define (initialize! this) (public void)
      (base-initializer this)
      (set (accessor this)
	   (member-accessor (member-name this))))

    (define (simplify m parent tail?)
      (set (enclosing-expression m) parent)
      (set (exp m)
	   (simplify (exp m) m #f))
      m)

    (define (unparse e)
      (new-array object 3
		 s-member
		 (unparse (exp e))
		 (member-name e)))

    (define (subexpressions e)
      (new-array object 1 (exp e)))

    (define (eval e env estack)
      (let ((val (eval (exp e) env estack)))
	(set-expression! estack e env)
	(read-accessor (accessor e) val))))


;  (define-class (member-reference exp member-name) expression
;    (define exp "expression" (public expression) null)
;    (define member-name (public string) null)
;    (define member (public member-info) null)
;    (define fieldinfo (private field-info) null)
;    (define propertyinfo (private property-info) null)
;    (define methodinfo (private method-info) null)
;    (define no-args (private static (array object)) (new-array object 0))

;    (define (simplify m parent tail?)
;      (set (enclosing-expression m) parent)
;      (set (exp m)
;	   (simplify (exp m) m #f))
;      m)

;    (define (unparse e)
;      (new-array object 3
;		 s-member
;		 (unparse (exp e))
;		 (member-name e)))

;    (define (subexpressions e)
;      (new-array object 1 (exp e)))

;    (define (eval e env estack)
;      (let ((val (eval (exp e) env estack)))
;	(set-expression! estack e env)
;	(cond ((not (null? (fieldinfo e)))
;	       (if (is-instance-of-type (declaring-type (fieldinfo e))
;					val)
;		   (get-field-value (fieldinfo e) val)
;		   (lookup-member e val env)))
;	      ((not (null? (propertyinfo e)))
;	       (if (is-instance-of-type (declaring-type (propertyinfo e))
;					val)
;		   (get-property-value (propertyinfo e)
;				       val
;				       no-args)
;		   (lookup-member e val env)))
;	      ((not (null? (methodinfo e)))
;	       (new closed-method-wrapper
;		    (member-name e)
;		    val
;		    (methodinfo e)))
;	      (else
;	       (lookup-member e val env)))))

;    (define (lookup-member e val (environment env)) (private object)
;      ;; Look it up and cache it.
;      (let ((t (type-of val))
;	    (retval null))
;	(let ((members (my-get-members t (member-name e))))
;	  (cond
;	   ;; Check for failure to find it in type t
;	   ((or (null? members)
;		(= (length members)
;		   0))
;	    (cond ((is? val type)
;		   (set retval
;			(lookup-static-member e
;					      (cast clr-type val)
;					      env)))
;		  (else
;		   ;(push-eval-stack e env)
;		   (throw! (unknown-member-exception
;			    val
;			    (member-name e))
;			   e
;			   env))))

;	   ;; We did indeed find something
;	   ((= (length members) 1)
;	    ;; Unique match
;	    (let ((mem (vector-ref members 0)))
;	      (let ((finfo (as mem field-info))
;		    (pinfo (as mem property-info))
;		    (minfo (as mem method-info)))
;		(cond ((not (null? finfo))
;		       (set (fieldinfo e)
;			    finfo)
;		       (set retval
;			    (get-field-value finfo val)))
;		      ((not (null? pinfo))
;		       (set (propertyinfo e)
;			    pinfo)
;		       (set retval
;			    (get-property-value pinfo
;						val
;						no-args)))
;		      (else
;		       (set minfo (get-base-definition minfo))
;		       (set (methodinfo e)
;			    minfo)
;		       (set retval
;			    (new closed-method-wrapper
;				 (member-name e)
;				 val
;				 minfo)))))))
;	   (else
;	    ;; Ambiguous match - must be an overloaded method.
;	    (set retval
;		 (new closed-ambiguous-method-wrapper
;		      (member-name e)
;		      val
;		      (member-name e))))))
;	retval))

;    (define (lookup-static-member e (clr-type tval) (environment env)) (private object)
;      ;; We must be looking up something static
;      (let ((members2 (my-get-members tval
;				      (member-name e)))
;	    (retval null))
;	(cond ((or (null? members2)
;		   (= (length members2) 0))
;	       ;; Complete failure.
;	       ;; The user is on crack.
;	       ;(push-eval-stack e env)
;	       (throw! (unknown-member-exception
;			tval
;			(member-name e))
;		       e
;		       env))
;	      ((= (length members2) 1)
;	       (let ((mem2 (vector-ref members2 0)))
;		 (let ((finfo2 (as mem2 field-info))
;		       (pinfo2 (as mem2 property-info))
;		       (minfo2 (as mem2 method-info)))
;		   (cond ((not (null? finfo2))
;			  (cond ((member-static? finfo2)
;				 (set (fieldinfo e)
;				      finfo2)
;				 (set retval
;				      (get-field-value finfo2
;						       tval)))
;				(else
;				 (set retval
;				      (new field-wrapper
;					   (member-name e)
;					   finfo2)))))
;			 ((not (null? pinfo2))
;			  (set (propertyinfo e)
;			       pinfo2)
;			  (set retval
;			       (get-property-value pinfo2
;						   tval
;						   no-args)))
;			 ((not (null? minfo2))
;			  (cond ((member-static? minfo2)
;				 (set retval
;				      (new closed-method-wrapper
;					   (member-name e)
;					   tval
;					   minfo2)))
;				(else
;				 (set retval
;				      (new method-wrapper
;					   (member-name e)
;					   minfo2)))))))))
;	      (else
;	       (set retval
;		    (new closed-ambiguous-static-method-wrapper
;			 (member-name e)
;			 tval
;			 (member-name e)))))
;	retval)))

  (define-parser (member "object-expression" "member-name")
    "Returns the value of the specified object member"
    member-parser null tuple p
    (unless (= (count tuple) 3)
      (throw (parse-error "Bad member syntax - should be X.Y or [member X Y]" tuple)))
    (let ((object-expression (parse p (vector-ref tuple 1) p))
	  (mem-name (vector-ref tuple 2)))
      (let ((maybe-global (as object-expression global-variable)))
	(if (and (not (null? maybe-global))
		 (not (null? (value maybe-global)))
		 (is? (value maybe-global)
		      namespace-base))
	    (let ((maybeimport (lookup (cast namespace-base
					     (value maybe-global))
				       (if (is? mem-name string)
					   (intern (cast string mem-name))
					   (cast symbol mem-name))
				       #t
				       #t
				       #t)))
	      (if (null? maybeimport)
		  (throw (new exception "No such variable in namespace"))
		  maybeimport))
	    (let ((real-member-name null))
	      (cond ((is? mem-name string)
		     (set real-member-name
			  (cast string mem-name)))
		    ((is? mem-name symbol)
		     (set real-member-name
			  (pname (cast symbol mem-name))))
		    (else
		     (throw (parse-error "Bad member name" tuple))))
	      (member-reference (parse p (vector-ref tuple 1) p)
				real-member-name))))))

  (define-class (member-assignment member-expression new-value)
    expression
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))
    (define member-expression (public member-reference) null)
    (define new-value (public expression) null)

    (define (simplify m parent tail?)
      (set (enclosing-expression m) parent)
      (set (member-expression m)
	   (simplify (member-expression m)
		     m
		     #f))
      (set (new-value m)
	   (simplify (new-value m)
		     m
		     #f))
      m)

    (define (unparse e)
      (new-array object 3
		 (unparse (member-expression e))
		 assignment-arrow
		 (unparse (new-value e))))

    (define (subexpressions e)
      (new-array object 2
		 (member-expression e)
		 (new-value e)))

    (define (eval e env estack)
      (eval-preamble e env)
      (set-expression! estack e env)
      (let ((obj (eval (exp (member-expression e))
		       env
		       estack))
	    (newval (eval (new-value e) env estack)))
	(set-expression! estack e env)
	(write-accessor (accessor (member-expression e))
			obj
			newval)
	missing-value))
      

;    (define (eval e env estack)
;      (eval-preamble e env)
;      (set-expression! estack e env)
;      (let ((obj (eval (exp (member-expression e))
;		       env
;		       estack))
;	    (newval (eval (new-value e) env estack))
;	    (member (member-name (member-expression e))))
;	(set-expression! estack e env)
;	(if (is? obj clr-type)
;	    (invoke-member (cast clr-type obj)
;			   member
;			   (bitwise-or public
;				       (bitwise-or set-field
;						   static))
;			   null
;			   obj
;			   (new-array object 1 newval))
;	    (invoke-member (type-of obj)
;			   member
;			   (bitwise-or (bitwise-or public
;						   instance)
;				       (bitwise-or set-field
;						   set-property))
;			   null
;			   obj
;			   (new-array object 1 newval))))
;      missing-value)
    )

  (define-parser (<-)
    "Changes the name/field on the left to have the value on the right"
    assignment-parser null tuple p
    (check-length tuple 3 3)
    (let ((lhs (parse p (vector-ref tuple 0) p))
	  (rhs (parse p (vector-ref tuple 2) p)))
      (cond ((is? lhs member-reference)
	     (member-assignment (cast member-reference lhs)
				rhs))
	    ((is? lhs application)
	     (let ((a (as lhs application)))
	       (let ((new-args (new-array expression
					  (+ (length (arguments a))
					     1))))
		 (copy-into (arguments a)
			    new-args
			    0)
		 (set (vector-ref new-args
				  (- (length new-args) 1))
		      rhs)
		 (make-application (make-application (parse root-namespace-kluge
							    s-setter
							    null)
						     (new-array expression
								1
								(function a)))
				   new-args))))
	    (else
	     (variable-assignment (cast variable lhs)
				  rhs)))))

  (define-class (method-call function arguments) application
    ("[Serializable]")
    (define (initialize! this) (public void)
      (base-initializer this))

    (define (eval e env estack)
      ;; Set up stack frame
      (now-evaluating estack e env
		      (eval-preamble e env)
		      ;; Determine function to evaluate
		      (let ((mr (cast member-reference
				      (function e)))
			    (args (new-array object (length (arguments e)))))
			(let ((ob (eval (exp mr)
					env estack))
			      (ma (accessor mr)))
			  ;; This is just so the unevaluated arguments say something
			  ;; meaningful when displayed in the debugger.
			  (copy-into (arguments e) args 0)
			  ;; Okay, now eval the arguments.
			  (dotimes (n (length args))
			    (set (vector-ref args n)
				 (eval (vector-ref (arguments e)
						   n)
				       env
				       estack)))
			  (set-expression! estack e env)
			  (cond ((not (check-normal (exp-execution-mode e)))
				 (let ((return-value null))
				   (now-calling! estack
						 (linked-list (new-array object 3
									 s-member
									 ob
									 (member-name mr))
							      (cast ilist args))
						 null
						 (begin
						   (break null null)
						   (set return-value
							(method-call-invoke
							 ma ob args estack))
						   ))
				   return-value))
				(else
				 (method-call-invoke ma ob args estack))))))))

  (define-class (while-expression test body) body-expression
    ("[Serializable]")
    (define test (public expression) null)

    (define (simplify w parent tail?)
      (set (enclosing-expression w) parent)
      (set (test w)
	   (simplify (test w) w #f))
      (dotimes (i (length (body w)))
	(set (vector-ref (body w) i)
	     (simplify (vector-ref (body w) i)
		       w
		       #f)))
      w)

    (define (unparse w)
      (let ((u (new-array object
			  (+ (length (body w))
			     2))))
	(set (vector-ref u 0) s-while)
	(set (vector-ref u 1)
	     (unparse (test w)))
	(dotimes (n (length (body w)))
	  (set (vector-ref u (+ n 2))
	       (unparse (vector-ref (body w) n))))
	u))

    (define (subexpressions e)
      (cons (test e)
	    (body e)))

    (define (eval w e estack)
      (now-evaluating! estack w e
		       (while (cast boolean (eval (test w) e estack))
			 (eval-body (body w) e estack)
			 (set-expression! estack w e)))
      missing-value))

  (define-parser (while "test" "body ...")
    "Repeatedly runs body until test is false"
    while-parser s-body tuple p
    (when (< (count tuple) 2)
      (throw (parse-error "While expression has not test"
			  tuple)))
    (when (< (count tuple) 3)
      (throw (missing-body-error "While expression has no statements to execute"
					   tuple)))
    (let ((body-length (- (count tuple)
			  2)))
      (let ((b (new-array expression body-length)))
	(declare-source-alias b
			      (if (> body-length 0)
				  (vector-ref tuple 2)
				  tuple))
	(dotimes (n body-length)
	  (let ((e (parse p
			  (vector-ref tuple (+ n 2))
			  p)))
	    (when (or (is? e variable)
		      (is? e constant))
	      (throw (unnecessary-code-error e tuple)))
	    (set (vector-ref b n)
		 e)))
	(while-expression (parse p (vector-ref tuple 1) p)
			  b))))

  ;(define-parser (when "test" "body ...")
;    "Executes all expressions is test is true.\\nUsed when you want to specify several expressions to run."
;    when-parser s-body tuple p
;    (check-length tuple 3 0)
;    (let ((test (parse p (vector-ref tuple 1) p)))
;      (cond ((= (count tuple) 3)
;	     (conditional test
;			  (parse p (vector-ref tuple 2) p)
;			  null))
;	    (else
;	     (let ((body (new-array expression (- (count tuple)
;						  2))))
;	       (dotimes (n (length body))
;		 (set (vector-ref body n)
;		      (parse p (vector-ref tuple (+ n 2)) p)))
;	       (conditional test
;			    (begin-expression body)
;			    null))))))

  (define-parser (when "test" "body ...")
    "Executes all expressions is test is true.\\nUsed when you want to specify several expressions to run."
    when-parser s-body tuple p
    (check-length tuple 3 0)
    (conditional (parse p (vector-ref tuple 1) p)
		 (parse-body tuple 2 p false)
		 null))

  ;(define-parser (unless "test" "body ...")
;    "Executes all expressions if test is false.\\nUsed when you want to specify several expressions to run."
;    unless-parser s-body tuple p
;    (check-length tuple 3 0)
;    (let ((test (make-application (parse root-namespace-kluge
;					 s-not
;					 root-namespace-kluge)
;				  (new-array expression 1
;					     (parse p (vector-ref tuple 1) p)))))
;      (cond ((= (count tuple) 3)
;	     (conditional test
;			  (parse p (vector-ref tuple 2) p)
;			  null))
;	    (else
;	     (let ((body (new-array expression (- (count tuple)
;						  2))))
;	       (dotimes (n (length body))
;		 (set (vector-ref body n)
;		      (parse p (vector-ref tuple (+ n 2)) p)))
;	       (conditional test
;			    (begin-expression body)
;			    null))))))

  (define-parser (unless "test" "body ...")
    "Executes all expressions if test is false.\\nUsed when you want to specify several expressions to run."
    unless-parser s-body tuple p
    (check-length tuple 3 0)
    (conditional (make-application (parse root-namespace-kluge
					 s-not
					 root-namespace-kluge)
				  (new-array expression 1
					     (parse p (vector-ref tuple 1) p)))
		 (parse-body tuple 2 p false)
		 null))

  ;;;
  ;;; LOCAL-USING-PARSER
  ;;;
  (define-class (local-using-parser namespaces parent) parser
    (define namespaces (public readonly (array namespace-base)) null)
    (define parent (public readonly parser) null)
    (define (parse l tuple p)
      (let ((s (as tuple symbol)))
	(unless (null? s)
	  (do-array (n (namespaces l))
		    (let ((v (lookup n s #f #f #t)))
		      (unless (null? v)
			(return v)))))
	(parse base tuple p))))

  (define-parser (with-namespaces "namespace-list" "expression")
    "Parses expression using specified namespaces"
    with-namespaces-parser null tuple p
    (unless (= (count tuple) 3)
      (throw (parse-error "With-namespaces expression should have two arguments"
			   tuple)))
    (let ((namespaces-arg (as (vector-ref tuple 1) ilist))
	  (expression-arg (vector-ref tuple 2)))
      (when (null? namespaces-arg)
	(throw (parse-error "First argument to with-namespaces must be a list of namespace names"
			     tuple)))
      (let ((namespaces (new-array namespace-base (count namespaces-arg))))
	(dotimes (i (count namespaces-arg))
	  (let ((name (vector-ref namespaces-arg i)))
	    (let ((np (parse p name p)))
	      (if (null? np)
		  (throw (undefined-variable-exception (cast global-variable
							     name)))
		  (let ((nv (as np global-variable)))
		    (if (not (null? nv))
			(let ((ns (as (value nv) namespace-base)))
			  (if (null? ns)
			      (throw (parse-error "Not a namespace" name))
			      (set (vector-ref namespaces i) ns)))
			(throw (parse-error "Not a namespace" name))))))))
	(let ((l (local-using-parser namespaces p)))
	  (parse l expression-arg l)))))

  (define-parser (the "type" "expression")
    "Declares expression to have the specified type"
    parser-for-the null tuple p
    (let ((t (parse-type-expression (vector-ref tuple 1)))
	  (expr (parse p (vector-ref tuple 2) p)))
      (set (declared-type expr) t)
      expr))

  (define-parser (declare-type "variable" "type")
    "Declares expression to have the specified type"
    declare-type-parser null tuple p
    (let ((t (parse-type-expression (vector-ref tuple 2)))
	  (expr (parse p (vector-ref tuple 1) p)))
      (when (is? expr global-variable-reference)
	(set expr (rvar (cast global-variable-reference expr))))
      (set (declared-type expr) t)
      expr))

  )   ; End of module